R Notebook

Setup

library(tidyverse)

Registered S3 method overwritten by 'dplyr':
  method           from
  print.rowwise_df     
-- Attaching packages --------------------------------------- tidyverse 1.2.1 --
v ggplot2 3.2.1     v purrr   0.3.2
v tibble  2.1.3     v dplyr   0.8.3
v tidyr   1.0.0     v stringr 1.4.0
v readr   1.3.1     v forcats 0.4.0
-- Conflicts ------------------------------------------ tidyverse_conflicts() --
x dplyr::filter() masks stats::filter()
x dplyr::lag()    masks stats::lag()

library(lubridate)

Vedh攼㸶fter pakke: 㤼㸱lubridate㤼㸲

Det f昼㸸lgende objekt er maskeret fra 㤼㸱package:base㤼㸲:

    date

library(readxl)
library(data.table)

Registered S3 method overwritten by 'data.table':
  method           from
  print.data.table     
data.table 1.12.6 using 4 threads (see ?getDTthreads).  Latest news: r-datatable.com

Vedh攼㸶fter pakke: 㤼㸱data.table㤼㸲

De f昼㸸lgende objekter er maskerede fra 㤼㸱package:lubridate㤼㸲:

    hour, isoweek, mday, minute, month, quarter, second, wday, week, yday, year

De f昼㸸lgende objekter er maskerede fra 㤼㸱package:dplyr㤼㸲:

    between, first, last

Det f昼㸸lgende objekt er maskeret fra 㤼㸱package:purrr㤼㸲:

    transpose

library(tsibble)

Vedh攼㸶fter pakke: 㤼㸱tsibble㤼㸲

Det f昼㸸lgende objekt er maskeret fra 㤼㸱package:data.table㤼㸲:

    key

De f昼㸸lgende objekter er maskerede fra 㤼㸱package:lubridate㤼㸲:

    interval, new_interval

Det f昼㸸lgende objekt er maskeret fra 㤼㸱package:dplyr㤼㸲:

    id

library(feasts)

Indl攼㸶ser kr攼㸶vet pakke: fabletools

library(tsibble)
library(feasts)

Walmart

wm_train <- fread("~/kaggle/walmart/train.csv") %>%
  janitor::clean_names() %>%
  mutate(date = ymd(date)) %>%
  mutate_at(vars(store, dept), as.factor)

wm_test<- fread("~/kaggle/walmart/test.csv") %>%
  janitor::clean_names() %>%
  mutate(date = ymd(date)) %>%                
  mutate_at(vars(store, dept), as.factor)

feats <- fread("~/kaggle/walmart/features.csv") %>% janitor::clean_names() %>% mutate(date = ymd(date))
stores <- fread("~/kaggle/walmart/stores.csv") %>% janitor::clean_names() %>% mutate(store = as.factor(store))

_

tsib %>%
  mutate(is_holiday = as.numeric(is_holiday)) %>%
  as.tibble() %>%
  group_by(store, dept) %>%
  summarize(
    cor = cor(weekly_sales, is_holiday, method = "spearman", use = "na.or.complete")
  ) %>%
  ungroup %>%
  mutate(mean_cor = mean(abs(cor), na.rm = TRUE)) %>%
  ggplot(aes(x = cor)) + geom_histogram() + geom_vline(aes(xintercept = mean_cor))

train_w_var <- tsib %>%
  ungroup %>%
  mutate(store = as.integer(store)) %>%
  left_join(feats %>% select(-is_holiday) %>% mutate(date = yearweek(date)), by = c("store", "date"))

get_correlations <- function(df) {
  df %>% 
    corrr::correlate(method = "spearman") %>%
    select(variable = rowname, cor = weekly_sales) %>%
    filter(variable != "weekly_sales") %>%
    as.tibble()
}

library(furrr)
plan(multiprocess)

cor_df <- train_w_var %>%
  mutate_at(vars(-date, -store, -dept), replace_na, replace = 0) %>%
  as.tibble() %>%
  group_by(store, dept) %>%
  select(-date) %>%
  nest() %>%
  mutate(cor = future_map(data, get_correlations, .progress = TRUE))
  
cor_df %>%
  unnest(cor) %>%
  group_by(variable) %>%
  mutate(mean_val = mean(abs(cor), na.rm = TRUE)) %>%
  ggplot(aes(x = cor)) + geom_histogram() + geom_vline(aes(xintercept = mean_val)) + facet_grid(~variable)

train_w_var %>%
  ggplot(aes(x = mark_down1, y = weekly_sales)) + geom_point() + geom_smooth()

overall_cor <- train_w_var %>%
  mutate_at(vars(-date, -store, -dept), replace_na, replace = 0) %>%
  as.tibble() %>%
  select(-date, -store, -dept) %>%
  nest() %>%
  mutate(cor = future_map(data, get_correlations, .progress = TRUE))

overall_cor %>% unnest(cor) %>% select(-data) %>% arrange(desc(abs(cor)))

rm(cor_df, feats, overall_cor,stores, train_w_var, tsib, wm_feats, wm_test, wm_train)

ex%>% 
    left_join(svd_var_exp_df$data[[5]] %>% mutate(store = as.integer(store))) %>% 
    mutate(weekly_sales = replace_na(weekly_sales, 0)) %>% 
    mutate(error = weekly_sales - rec) %>%
    group_by(comp) %>%
    summarize(
      sd_error = sd(error),
      sd_sales = sd(weekly_sales),
      pct_error = sd_error/sd_sales,
      var_exp = 1 - pct_error
    )

Joining, by = c("date", "is_holiday", "store")

#Rossman

rs_tsib <- rs_trn %>%
  as_tsibble(key = store, index = date)

rs_feats <- rs_tsib %>%
  features(sales, list(feat_stl, feat_spectral))

rs_feats %>%
  gather(key = variable, value = value, seasonal_strength_week, trend_strength, spectral_entropy) %>%
  ggplot(aes(x = value)) + geom_histogram() + facet_wrap(~variable)
  

rs_feats %>%
  mutate(ds = "Rossmann") %>% 
  select(-store) %>%
  mutate(seas_strength = seasonal_strength_week) %>%
#  bind_rows(
# wm_feats %>% mutate(ds = "Walmart") %>% select(-store) %>% mutate(seas_strength = seasonal_strength_year)
#  ) %>%
  gather(key = variable, value = value, seas_strength, trend_strength, spectral_entropy) %>%
  ggplot(aes(x = value, fill = ds)) + geom_histogram() + facet_wrap(ds~variable)

rs_w_feat <- rs_trn %>%
  left_join(rs_states) %>%
  left_join(weather, by = c("state_name" = "file", "date"))

rs_cor_df <- rs_w_feat %>%
  select(-day_of_week, -state_name, -state, -max_gust_speed_km_h) %>%
  as.tibble() %>%
  group_by(store) %>%
  mutate_if(is.character, ~as.numeric(as.factor(.x))) %>%
  select(-date, weekly_sales = sales) %>%
  nest() %>%
  mutate(cor = future_map(data, get_correlations, .progress = TRUE, ))

rs_cor_df %>%
  unnest(cor) %>%
  group_by(variable) %>%
  mutate(mean_val = mean(abs(cor), na.rm = TRUE)) %>%
  ggplot(aes(x = cor)) + geom_histogram() + geom_vline(aes(xintercept = mean_val)) + facet_wrap(~variable)

overall_cor <- rs_w_feat %>%
  select(-day_of_week, -state_name, -state, -max_gust_speed_km_h) %>%
  as.tibble() %>%
  mutate_if(is.character, ~as.numeric(as.factor(.x))) %>%
  select(-date, weekly_sales = sales) %>%
  get_correlations()

overall_cor %>% arrange(desc(abs(cor)))

pcs <- rs_feats %>%
  select(-store) %>%
  mutate_all(~replace_na(.x, replace = mean(.x, na.rm = TRUE))) %>%
  prcomp(scale=TRUE)


autoplot(pcs, loadings = TRUE, loadings.label = TRUE)

rm(rs_trn, rs_tsib, rs_w_feat, weather, rs_store, rs_states, rs_feats, rs_cor_df)

Grupo Bimbo

tictoc::tic()
bb_fact <- bb_trn[, lapply(.SD, as.factor), .SDcols = c("agencia_id", "canal_id", "ruta_sak", "cliente_id", "producto_id")]
tictoc::toc()

14.53 sec elapsed

obs <- agg[, .(cliente_id, producto_id, semana, exists = 1L)]

bt <- dcast(obs, cliente_id + producto_id ~ semana, value.var = "exists") %>%
  melt(., id.vars = c("cliente_id", "producto_id"), measure.vars =  c("3", "4", "5", "6", "7", "8", "9"), variable.name = "semana")

full_ds <- merge(bt[, semana := as.integer(semana)], agg, all.x = TRUE)

rm(bt, agg)
gc()

for (j in seq_len(ncol(full_ds))) {
  set(full_ds, which(is.na(full_ds[[j]])),j,0)
}  

rm(bb_fact, bb_test_fact)

full_ds <- full_ds[order(cliente_id, producto_id, semana)]

safe_spec <- possibly(feat_spectral, otherwise = NA)
full_ds[, .(entropy = safe_spec(demanda_uni_equil) %>% as.numeric), by = .(cliente_id, producto_id)]

plan(multiprocess)
full_ds_feat <- full_ds[, .(.(demanda_uni_equil)), by = .(cliente_id, producto_id)]
full_ds_feat[, ent := future_map(V1, ~safe_spec(.x) %>% as.numeric)]